home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
ppp.zip
/
PPP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-03-29
|
29KB
|
833 lines
(* PPP - Author: Martin Bless 890224 *)
(* Pretty Print Pascal. Compiled with Turbo-Pascal 5.0 *)
{$UNDEF debug} (* may be changed to DEFINE *)
{$UNDEF sort} (* use DEFINE for nonordered keywords *)
{$A+,B-,D+,E+,F-,I+,L-,N-,O-,R+,S+,V-}
{$M 16384,0,655360}
PROGRAM PPP;
USES
Crt, Dos;
CONST
tabLen = 8; (* # of blanks for tabs *)
nKeyWords = 245; (* number of keywords *)
keyWordLength = 25; (* length of keywords *)
idSet = ['A'..'Z', 'a'..'z', (* legal chars for *)
'0'..'9','_']; (* identifier *)
printSet = [#3..#6, #21, #32..#126, (* printable chars of *)
#128..#254]; (* NEC-P6 *)
TYPE
DestType = (console, printer, necP6, datei, norton);
KeyWordType = STRING[ keyWordLength];
KeyWordsType = ARRAY[ 1..nKeyWords] OF KeyWordType;
ColorTableType = ARRAY[ 0..7] OF BYTE;
CONST
colorTable: ColorTableType =(
$07, (* light grey:=hellgrau *) (* normal text *)
$07, (* hellgrau *) (* comments *)
$0F, (* weia *) (* keyword class '1' *)
$07, (* hellgrau *) (* keyword class '2' *)
$07, (* hellgrau *) (* keyword calss '3' *)
$07, (* hellgrau *) (* keyword class '4' *)
$07, (* hellgrau *) (* keyword class '5' *)
$07 (* hellgrau *) (* keyword class '6' *)
);
(* IMPORTANT: keywords in alphabetic order, CASE INDEPENDENT! *)
(* MUST have trailing blank and class number *)
key:KeyWordsType = (
'Abs 2', 'ABSOLUTE 1', 'Addr 2', 'AND 1', 'Append 2', 'Arc 2',
'ArcTan 2', 'ARRAY 1', 'Assign 2', 'AssignCrt 2', 'Bar 2',
'Bar3D 2', 'BEGIN 1', 'BlockRead 2', 'BlockWrite 2', 'BOOLEAN 1',
'BYTE 1', 'CASE 1', 'CHAR 1', 'ChDir 2', 'Chr 2', 'Circle 2',
'ClearDevice 2', 'ClearViewPort 2', 'Close 2', 'CloseGraph 2',
'ClrEol 2', 'ClrScr 2', 'Concat 2', 'CONST 1', 'Copy 2', 'Cos 2',
'CSeg 2', 'DEC 1', 'Delay 2', 'Delete 2', 'DelLine 2',
'DetectGraph 2', 'DiskFree 2', 'DiskSize 2', 'Dispose 2',
'DIV 1', 'DO 1', 'DosExitCode 2', 'DOWNTO 1', 'DrawPoly 2',
'DSeg 2', 'Ellipse 2', 'ELSE 1', 'END 1', 'Eof 2', 'Eoln 2',
'Erase 2', 'Exec 2', 'EXIT 1', 'Exp 2', 'EXTERNAL 1', 'FALSE 1',
'FILE 1', 'FilePos 2', 'FileSize 2', 'FillChar 2', 'FillPoly 2',
'FindFirst 2', 'FindNext 2', 'FloodFill 2', 'Flush 2', 'FOR 1',
'FORWARD 1', 'Frac 2', 'FreeMem 2', 'FUNCTION 1',
'GetArcCoords 2', 'GetAspectRatio 2', 'GetBkColor 2',
'GetColor 2', 'GetDate 2', 'GetDir 2', 'GetFAttr 2',
'GetFillSettings 2', 'GetFTime 2', 'GetGraphMode 2',
'GetImage 2', 'GetIntVec 2', 'GetLineSettings 2', 'GetMaxX 2',
'GetMaxY 2', 'GetMem 2', 'GetPalette 2', 'GetPixel 2',
'GetTextSettings 2', 'GetTime 2', 'GetViewSettings 2', 'GetX 2',
'GetY 2', 'GOTO 1', 'GotoXY 2', 'GraphErrorMsg 2',
'GraphResult 2', 'HALT 2', 'Hi 2', 'HighVideo 2', 'IF 1',
'ImageSize 2', 'IMPLEMENTATION 1', 'IN 1', 'INC 1',
'InitGraph 2', 'INLINE 1', 'Insert 2', 'InsLine 2', 'Int 2',
'INTEGER 1', 'INTERFACE 1', 'INTERRUPT 1', 'Intr 2',
'IOResult 2', 'Keep 2', 'KeyPressed 2', 'LABEL 1', 'Length 2',
'Line 2', 'LineRel 2', 'LineTo 2', 'Ln 2', 'Lo 2', 'LongInt 1',
'LowVideo 2', 'Mark 2', 'MaxAvail 2', 'MemAvail 2', 'MkDir 2',
'MOD 1', 'Move 2', 'MoveRel 2', 'MoveTo 2', 'MsDos 2', 'New 2',
'NIL 1', 'NormVideo 2', 'NoSound 2', 'NOT 1', 'Odd 2', 'OF 1',
'Ofs 2', 'OR 1', 'Ord 2', 'OutText 2', 'OutTextXY 2', 'PACKED 1',
'PackTime 2', 'ParamCount 2', 'ParamStr 2', 'Pi 2', 'PieSlice 2',
'POINTER 1', 'Pos 2', 'Pred 2', 'PROCEDURE 1', 'PROGRAM 1',
'Ptr 2', 'PutImage 2', 'PutPixel 2', 'Random 2', 'Randomize 2',
'Read 2', 'ReadKey 2', 'ReadLn 2', 'RECORD 1', 'Rectangle 2',
'Release 2', 'Rename 2', 'REPEAT 1', 'Reset 2', 'RestoreCrt 2',
'RestoreCrtMode 2', 'Rewrite 2', 'RmDir 2', 'Round 2', 'Seek 2',
'SeekEof 2', 'SeekEoln 2', 'Seg 2', 'SET 1', 'SetActivePage 2',
'SetAllPalette 2', 'SetBkColor 2', 'SetColor 2', 'SetDate 2',
'SetFAttr 2', 'SetFillPattern 2', 'SetFillStyle 2', 'SetFTime 2',
'SetGraphMode 2', 'SetIntVec 2', 'SetLineStyle 2',
'SetPalette 2', 'SetTextBuf 2', 'SetTextJustify 2',
'SetTextStyle 2', 'SetTime 2', 'SetViewPort 2',
'SetVisualPage 2', 'SHL 1', 'ShortInt 1', 'SHR 1', 'Sin 2',
'SizeOf 2', 'Sound 2', 'SPtr 2', 'Sqr 2', 'Sqrt 2', 'SSeg 2',
'Str 2', 'STRING 1', 'Succ 2', 'Swap 2', 'TEXT 1',
'TextBackground 2', 'TextColor 2', 'TextHeight 2', 'TextMode 2',
'TextWidth 2', 'THEN 1', 'TO 1', 'TRUE 1', 'Trunc 2',
'Truncate 2', 'TYPE 1', 'UNIT 1', 'UnpackTime 2', 'UNTIL 1',
'UpCase 2', 'USES 1', 'Val 2', 'VAR 1', 'WhereX 2', 'WhereY 2',
'WHILE 1', 'Window 2', 'WITH 1', 'WORD 1', 'Write 2',
'WriteLn 2', 'XOR 1'
);
VAR (* general global *)
ch: CHAR; (* current char of source file *)
lk: CHAR; (* last key *)
goFlag: CHAR; (* #32 = ' ' = go! *)
VAR (* keyword finding *)
keyIndex: WORD; (* index of keyword found *)
idPos: WORD; (* position in id string *)
id: KeyWordType; (* identifier buffer *)
VAR (* program flow *)
convert: BOOLEAN; (* convert KeyWords? *)
VAR (* printing *)
dest: DestType; (* output destiniation *)
lpp: WORD; (* lines per page *)
cpl: WORD; (* columns per line *)
colCnt: WORD; (* current column *)
lineCnt: WORD; (* current line *)
pageCnt: WORD; (* current page *)
lMargin: WORD; (* left margin in # of blanks *)
inComment: BOOLEAN; (* true if comment printing is on *)
inKeyWord: BOOLEAN; (* true if keyword printing is on *)
color: WORD; (* index to colorTable *)
VAR (* for Norton Guides *)
totalBytes: WORD; (* count all bytes output *)
shortCnt: WORD; (* count # of short entries *)
VAR (* files *)
f1File: Text; (* input file *)
f2File: Text; (* output file *)
f1Name, f2Name: STRING[ 80]; (* fileNames *)
f1Open, f2Open: BOOLEAN; (* open indicators *)
FUNCTION LastKey:CHAR; (* get last key pressed, #0 if none *)
VAR
rk: CHAR;
BEGIN
rk := #0;
IF KeyPressed THEN BEGIN;
rk := ReadKey;
IF rk = #0 THEN BEGIN (* eat function key *)
rk := ReadKey;
rk := #0;
END;
END;
LastKey := rk;
END;
FUNCTION WaitKey: CHAR; (* wait for keypress *)
BEGIN
WHILE NOT KeyPressed DO; (* loop *)
WaitKey := LastKey;
END;
FUNCTION UpStr( s:STRING):STRING; (* convert string to *)
VAR (* upper case *)
c: WORD;
BEGIN
FOR c:= 1 TO Length( s) DO BEGIN
UpStr[c] := UpCase( s[c]);
END;
UpStr[0] := s[0]; (* set correct length *)
END;
{$IFDEF sort}
PROCEDURE SortKeyWords; (* case independent! *)
VAR
x, y: KeyWordType;
PROCEDURE QSort( l, r:WORD); (* Quicksort (rekursiv) *)
VAR
i, j: WORD;
BEGIN
i := l;
j := r;
x := UpStr( key[ (l+r) DIV 2]); (* case independent! *)
REPEAT
WHILE UpStr( key[ i]) < x DO INC(i); (* case independent! *)
WHILE x < UpStr( key[ j]) DO DEC(j); (* case independent! *)
IF i <= j THEN BEGIN
y := key[ i];
key[ i] := key[ j];
key[ j] := y;
INC( i);
DEC( j);
END;
UNTIL i > j;
IF l < j THEN QSort( l, j);
IF i < r THEN QSort( i, r);
END; (* QSort *)
BEGIN
IF nKeyWords > 0 THEN QSort( 1, nKeyWords);
END; (* SortKeyWords *)
{$ENDIF}
{$IFDEF debug}
PROCEDURE ShowKeyWords;
VAR
c: WORD;
BEGIN
FOR c:= 1 TO nKeyWords DO BEGIN
WriteLn( c:5, '':5, key[c]);
END;
END;
{$ENDIF}
FUNCTION Space( n:BYTE):STRING; (* return string of n spaces *)
VAR
c: WORD;
BEGIN
Space[0] := Chr(n);
FOR c := 1 TO n DO BEGIN
Space[c] := ' ';
END;
END;
PROCEDURE SendCh( c:CHAR); (* all output done here charwise *)
BEGIN (* IOResult may be checked *)
(*$I-*)
Write( f2File, c); (* !!!!! OUTPUT TO f2File !!!!! *)
(*$I+*)
IF IOResult <> 0 THEN BEGIN (* stop program immediately *)
IF f1Open THEN Close( f1File); (* try a clean exit *)
IF f2Open THEN Close( f2File); (* *)
WriteLn('PPP - Error on output to '#39+
f2Name+#39); (* let user know *)
Halt( 1); (* abort with errorlevel 1 *)
END;
INC( totalBytes); (* count bytes for norton guides *)
END;
PROCEDURE SendStr( s:STRING); (* send string *)
VAR
c: WORD;
BEGIN
FOR c:= 1 TO Length( s) DO BEGIN
SendCh( s[c]);
END;
END;
PROCEDURE AbortProgram( msg:STRING); (* no msg = no error *)
BEGIN
IF f2Open AND (msg<>'') AND
(colCnt <> 1) THEN
BEGIN
SendStr( #13#10); (* try to close line *)
END;
IF f1Open THEN Close( f1File);
IF f2Open THEN Close( f2File);
IF msg[0] > #0 THEN BEGIN
WriteLn;
WriteLn( msg);
Halt( 1); (* abort with errorlevel 1 *)
END;
Halt( 0); (* abort with errorlevel 0 (no error) *)
END;
FUNCTION DateStr: STRING; (* returns TT.MM.JJ *)
VAR
yy, mm, dd, dow: WORD;
ys, ms, ds: STRING[4];
BEGIN
GetDate ( yy, mm, dd, dow);
Str( dd:2, ds); IF dd<10 THEN ds[1] := '0';
Str( mm:2, ms); IF mm<10 THEN ms[1] := '0';
Str( yy:4, ys);
DateStr := ds+'.'+ms+'.'+Copy(ys,3,2);
END;
FUNCTION TimeStr: STRING; (* returns HH:MM:SS *)
VAR
hh, mm, sec, sec100: WORD;
hs, ms, ss: STRING[4];
BEGIN
GetTime ( hh, mm, sec, sec100);
Str( hh:2, hs); IF hh<10 THEN hs[1] := '0';
Str( mm:2, ms); IF mm<10 THEN ms[1] := '0';
Str( sec:2, ss); IF sec<10 THEN ss[1] := '0';
TimeStr := hs+':'+ms+':'+ss;
END;
PROCEDURE KeyWordOn; (* a keyword follows *)
BEGIN
inKeyWord := TRUE;
CASE dest OF
console: TextAttr := colorTable[ color];
necP6 : IF color = 2 THEN BEGIN
SendStr( #27'E'); (* Shadowed font ON *)
END;
printer: ;
datei : ;
norton : IF color = 2 THEN BEGIN
SendStr('^B'); (* highlighted ON *)
END;
END;
END;
PROCEDURE KeyWordOff; (* end of keyword *)
BEGIN
inKeyWord := FALSE;
CASE dest OF
console: TextAttr := colorTable[ 0];
necP6 : IF color = 2 THEN BEGIN
SendStr( #27'F'); (* Shadowed font OFF *)
END;
printer: ;
datei : ;
norton : IF color = 2 THEN BEGIN
SendStr('^N'); (* back to normal *)
END;
END;
END;
PROCEDURE CommentOn; (* a comment follows *)
BEGIN
inComment := TRUE;
CASE dest OF
necP6: SendStr(#27'4'); (* italics ON *)
console: TextAttr := colorTable[1]; (* comment color *)
printer: ;
datei : ;
END;
END;
PROCEDURE CommentOff; (* end of comment *)
BEGIN
inComment := FALSE;
CASE dest OF
necP6: SendStr(#27'5'); (* italics OFF *)
Console: TextAttr := colorTable[0]; (* normal color *)
printer: ;
datei : ;
END;
END;
PROCEDURE PrintTitle; (* only when printer format selected *)
VAR
c, tabPos: WORD;
s: STRING[50];
myInComment: BOOLEAN;
myInKeyWord: BOOLEAN;
BEGIN
IF NOT (dest IN
[printer, necP6]) THEN
BEGIN
EXIT; (* if not for printer *)
END;
myInComment := inComment; (* print headline always normal *)
myInKeyWord := inKeyWord;
IF inComment THEN CommentOff;
IF inKeyWord THEN KeyWordOff;
SendCh( #13); (* print head to beginning of line *)
FOR c:= 1 TO 2 DO BEGIN
SendCh( #10); (* empty lines *)
INC( lineCnt);
END;
SendStr( Space( lMargin)); (* left margin *)
SendStr( DateStr+' '+TimeStr);
Str( pageCnt:3, s);
SendStr( ' Seite'+s); (* page number *)
colCnt := lMargin+1+8+2+8+7+3; (* adjust column count *)
SendStr( Space( cpl - colCnt - Length( f1Name)+1));
SendStr( f1Name ); (* print file name right justified *)
SendCh( #13); (* back to beginning of line *)
colCnt := 1;
FOR c:= 1 TO 3 DO BEGIN
SendCh( #10); (* 2 empty lines *)
INC( lineCnt);
END;
IF myInComment THEN CommentOn; (* restore printing mode *)
IF myInKeyWord THEN KeyWordOn;
END;
FUNCTION ShortString:String; (* for norton guides *)
VAR (* insert: !SHORT ... *)
s: STRING[10];
BEGIN
INC( shortCnt);
Str( shortCnt, s);
ShortString := '!SHORT '+f1Name+' ...'+s+#13+#10;
END;
PROCEDURE LeftMargin; (* send blanks for left margin *)
VAR
c: WORD;
BEGIN
FOR c := 1 TO lMargin DO BEGIN
SendCh( ' ');
INC( colCnt); (* count columns *)
END;
END;
PROCEDURE NextPage; (* next printing page *)
BEGIN
INC( pageCnt); (* count pages *)
colCnt := 1;
lineCnt := 1;
IF NOT (dest IN [console, printer, necP6]) THEN BEGIN
EXIT; (* nothing inserted, if destination is a file *)
END;
IF dest = console THEN BEGIN
IF goFlag <> ' ' THEN BEGIN
Write( f2File, Space( 60), '(Space-) Bar ...');
lk := WaitKey;
IF lk=#27 THEN BEGIN (* ESCape key pressed *)
AbortProgram( ''); (* aborted by user *)
END;
IF lk <> #0 THEN BEGIN
goFlag := lk; (* save last key *)
END;
SendCh( #13);
ClrEol;
END;
EXIT;
END;
SendCh( #13); (* back to column 1 *)
SendCh( #12); (* send FORM FEED character *)
END;
PROCEDURE NextLine; (* next line to print *)
BEGIN
SendCh( #13);
colCnt := 1;
SendCh( #10);
INC( lineCnt);
IF (lineCnt >= lpp) THEN BEGIN (* beyond lines per page? *)
NextPage;
END;
IF totalBytes > 11500 THEN BEGIN (* about 12000 ... *)
IF dest = norton THEN BEGIN
SendStr( ShortString); (* chop to pieces *)
END;
totalBytes := 0;
END;
END;
PROCEDURE CheckColumn; (* check next printing position *)
BEGIN
IF (colCnt > cpl) AND (* beyond columns per line? *)
(dest IN [printer, necP6, norton]) THEN
BEGIN
NextLine;
END;
IF (colCnt=1) AND (lineCnt=1) THEN BEGIN
PrintTitle;
END;
IF colCnt=1 THEN BEGIN
LeftMargin;
END;
END;
PROCEDURE CheckTopOfForm; (* at top of form? *)
BEGIN
IF (colCnt=1) AND (lineCnt=1) THEN BEGIN
PrintTitle;
END;
END;
PROCEDURE ListCh( c:CHAR); (* all characters to be printed *)
(* and formatted have to pass *)
BEGIN (* this filter *)
IF c = #10 THEN BEGIN
CheckTopOfForm; (* print title, if at line 1 *)
NextLine;
EXIT;
END;
IF c IN printSet THEN BEGIN (* Is it a printable character? *)
CheckColumn; (* end of line or pos 1? *)
SendCh( c); (* finally send char *)
INC( colCnt); (* adjust column counter *)
END;
IF (c = '^') AND (dest=norton) THEN BEGIN
SendCh('^'); (* send double up arrow for norton guides *)
END;
IF c = #9 THEN BEGIN (* tabulator? *)
ListCh(' '); (* RECURSION! *)
WHILE ((colCnt-lMargin) MOD tabLen) <> 1 DO BEGIN
ListCh(' '); (* tab to pos 1,9,17 ... *)
END;
END;
(* ignore unprintable characters here! *)
END;
PROCEDURE ListString( s:STRING); (* send string to ListCh *)
VAR
ch: CHAR;
BEGIN
FOR ch := #1 TO s[0] DO BEGIN
ListCh( s[ ORD(ch)] );
END;
END;
PROCEDURE InitPrinting;
BEGIN (* set up defaults *)
colCnt := 1; (* column count *)
lineCnt := 1; (* line count *)
pageCnt := 1; (* page count *)
lMargin := 0; (* # of blanks for left margin *)
totalBytes := 0;
shortCnt := 0;
inComment := FALSE;
inKeyWord := FALSE;
CASE dest OF
datei: BEGIN
lpp := $FFFF; (* not relevant *)
cpl := $FFFF; (* not relevant *)
END;
console: BEGIN (* To screen: *)
lpp := 24; (* stop after 24 lines *)
cpl := 80; (* 80 columns per line *)
SendStr( #13#10#10); (* start with empty line *)
END;
printer: BEGIN (* To standard printer: *)
lpp := 66; (* lines per page *)
cpl := 80; (* columns per line *)
lMargin := 8; (* 8 * 0.254 cm = 2.032 cm *)
END;
norton: BEGIN (* To norton guides: *)
lMargin := 1; (* much better! *)
lpp := $FFFF;
cpl := 77; (* links + rechts 1 #32 *)
SendStr( ShortString); (* start 1st short entry *)
SendStr( '^B'+f1Name+ (* and include file name *)
'^N'#13#10#13#10);
END;
necP6: BEGIN
SendStr(#27#0); (* reset printer *)
SendStr(#27'R'#0); (* american fontset *)
SendStr(#27'M'); (* 12 CPI = 96 cpl *)
SendStr(#27'l'#12); (* left margin *)
lpp := 69; (* use 69 of 72 *)
cpl := 80; (* columns per line (12+80+4) *)
lMargin := 0; (* hardware left margin *)
END;
END; (* case *)
END;
PROCEDURE CondFF; (* conditional form feed *)
BEGIN (* avoid empty page *)
IF dest IN [necP6, printer] THEN BEGIN
IF (colCnt > 1) OR (lineCnt > 1) THEN BEGIN
NextPage;
END;
END;
END;
PROCEDURE Angaben; (* get parameters from commandline *)
VAR
par3: STRING;
BEGIN
convert := (Pos('-C',UpStr(ParamStr(4)))=0); (* convertflag *)
f1Open := FALSE;
f2Open := FALSE;
f1Name := ParamStr( 1); (* input filename *)
f1Name[1] := UpCase( f1Name[1]); (* 1st char to upper *)
IF Pos('.',f1Name) = 0 THEN BEGIN (* check for .PAS *)
f1Name := f1Name + '.PAS';
END;
Assign( f1File, f1Name);
(*$I-*)
Reset( f1File); (* open INPUT file *)
(*$I+*)
IF IOResult <> 0 THEN BEGIN
AbortProgram('PPP - Error: file '#39+f1Name+#39' not found');
END;
f1Open := TRUE;
IF ParamCount > 1 THEN
f2Name := UpStr( ParamStr(2)) (* output file name *)
ELSE BEGIN
f2Name:='CON'; (* CON is default *)
END;
IF (Pos('.',f2Name)=0) AND (* copy Ext from input? *)
('CON' <> f2Name) AND
('PRN' <> f2Name) THEN
BEGIN
f2Name := f2Name+Copy( f1Name, Pos('.',f1Name),255);
END;
IF UpStr(f1Name) = UpStr(f2Name) THEN BEGIN
AbortProgram('PPP - Error: In- and output file '#39 +
f1Name + #39' identically');
END;
IF f2Name = 'CON' THEN
AssignCrt( f2File) (* use CRT *)
ELSE BEGIN
Assign( f2File, f2Name);
END;
IF Pos('-A', UpStr(ParamStr(4)))>0 THEN BEGIN
(*$I-*)
Append( f2File); (* Append *)
(*$I+*)
IF IOResult=0 THEN BEGIN
f2Open := TRUE;
END;
END;
IF NOT f2Open THEN BEGIN
(*$I-*)
Rewrite( f2File); (* Rewrite *)
(*$I+*)
IF IOResult = 0 THEN BEGIN
f2Open := TRUE;
END;
END;
IF NOT f2Open THEN BEGIN
AbortProgram('PPP - Error while opening file '+
#39+f2Name+#39);
END;
IF ParamCount > 2 THEN
par3 := UpStr( ParamStr(3)) (* find destination *)
ELSE BEGIN
par3 := ''; (* defaults ... *)
IF f2Name='CON' THEN par3 := 'CON';
IF f2Name='PRN' THEN par3 := 'PRN';
END;
dest := datei;
IF par3 = 'CON' THEN BEGIN dest:=console; EXIT; END;
IF par3 = 'NECP6' THEN BEGIN dest:=necP6; EXIT; END;
IF par3 = 'PRN' THEN BEGIN dest:=printer; EXIT; END;
IF par3 = 'NORTON' THEN BEGIN dest:=norton; EXIT; END;
END;
PROCEDURE GetCh; (* read next char from INPUT file *)
BEGIN
IF Eof( f1File) THEN BEGIN
IF colCnt <> 1 THEN BEGIN
SendStr( #13#10); (* finish line *)
END;
AbortProgram('PPP - WARNING: unexpected end of file');
END;
Read( f1File, ch);
END;
PROCEDURE Copy;
BEGIN
ListCh( ch); (* current char to formatter *)
GetCh; (* get next one *)
END;
FUNCTION NoKeyWord:BOOLEAN; (* Binary search. Returns TRUE, *)
VAR (* if current identifier is not *)
i,l,r,m: WORD; (* a keyword *)
BEGIN
l := 1;
r := nKeyWords;
id[ idPos] := ' '; (* mark end of identifier *)
REPEAT
m:=(l+r) DIV 2;
keyIndex := m;
i:=1;
WHILE (UpCase(id[i])=UpCase(key[m,i])) AND
(id[i] <> ' ') DO
BEGIN
INC( i);
END;
IF UpCase(id[i])<=UpCase(key[m,i]) THEN BEGIN r:=m-1; END;
IF UpCase(id[i])>=UpCase(key[m,i]) THEN BEGIN l:=m+1; END;
UNTIL l>r;
NoKeyWord := (l=r+1); (* TRUE if identifier = NoKeyWord *)
END;
PROCEDURE ProcessText; (* whole input file *)
PROCEDURE ProcessChar; (* deal with current char *)
PROCEDURE Comment1; (* process ( * comment *)
BEGIN
Copy; (* process '*' *)
REPEAT
WHILE ch <> '*' DO BEGIN (* look for final '*' *)
Copy;
END;
Copy;
UNTIL ch=')'; (* does ')' follow immediately? *)
Copy;
END;
PROCEDURE ProcessUpTo( endCh: CHAR); (* copy until endCh found *)
BEGIN
Copy;
WHILE ch <> endCh DO BEGIN
Copy;
END;
Copy;
END;
PROCEDURE Collect; (* collect chars to form identifier *)
VAR
i: WORD;
BEGIN
idPos := 1;
REPEAT
id[ idPos] := ch;
INC( idPos);
GetCh;
UNTIL (NOT( ch IN idSet)) OR (idPos > KeyWordLength);
IF (idPos > keyWordLength) OR (* shortcut evaluation *)
NoKeyWord THEN (* MUST be ON! {$B-} *)
BEGIN
FOR i := 1 TO idPos-1 DO BEGIN (* NO keyword! *)
ListCh( id[i]); (* print collected stuff *)
END;
EXIT;
END;
(* keyword found *)
color := Ord( key[ keyIndex, (* find keyword class *)
idPos+1]) - Ord('1');
color := (color + 2) MOD 8; (* make sure: 0..7 *)
KeyWordOn; (* signal start of keyword *)
FOR i:=1 TO idPos-1 DO BEGIN
ListCh( key[ keyIndex, i]); (* print keyword *)
END;
KeyWordOff; (* signal end of keyword *)
END; (* Collect *)
BEGIN (* ProcessChar *)
IF NOT convert THEN BEGIN (* conversion inhibited? *)
Copy; (* yes, so copy only *)
EXIT;
END;
IF (UpCase(ch)>='A') AND
(UpCase(ch)<='Z') THEN
BEGIN
Collect; (* collect identifier *)
EXIT;
END;
IF ch = '(' THEN BEGIN { a '(*' comment? }
GetCh;
IF ch = '*' THEN BEGIN
CommentOn; (* signal start of comment *)
ListCh('(');
Comment1; (* process this kind of comment *)
CommentOff; (* signal end of comment *)
EXIT;
END
ELSE BEGIN
ListCh('(');
EXIT;
END;
END;
IF ch = '{' THEN BEGIN (* a '{' comment? *)
CommentOn; (* signal start of comment *)
ProcessUpTo( '}'); (* process this kind of comment *)
CommentOff; (* signal end of comment *)
EXIT;
END;
IF ch = #39 THEN BEGIN
ProcessUpTo( #39); (* process string constant *)
EXIT;
END;
Copy; (* nothing special, so copy! *)
END; (* ProcessChar *)
BEGIN (* ProcessText *)
lk := #0; (* last key pressed *)
goFlag := #13; (* #32 = ' ' = go *)
GetCh; (* provide 1st char *)
WHILE NOT(Eof(f1File)) AND
(lk<>#27) DO
BEGIN
ProcessChar;
lk := LastKey; (* check keyboard *)
IF lk <> #0 THEN BEGIN (* key pressed? *)
goFlag := lk; (* save pressed key *)
IF (goFlag<>' ') AND
(dest=console) THEN
BEGIN
lineCnt := 9999; (* pause after next line *)
END;
END;
END;
END; (* ProcessText *)
PROCEDURE Help; (* redirect to printer with CTRL+P *)
BEGIN
WriteLn;
WriteLn('PPP - Pretty Print Pascal. Autor: Martin Blea 890224');
WriteLn('====================================================');
WriteLn(
'correct start: PPP [file] [to] [how] [switches]');
WriteLn(
' Example: PPP Test.pas prn necp6 -p');
WriteLn;
WriteLn(' file: file name of source. (1. Parameter)');
WriteLn(' '#39'.PAS'#39' will be added if necessary.');
WriteLn;
WriteLn(' to: output filename or device. (2. Parameter)');
WriteLn(' (nothing) = output to screen');
WriteLn(' CON = output to screen');
WriteLn(' PRN = output to printer');
WriteLn(' how: (3. Parameter)');
WriteLn(' (nothing) = suitable for destination file');
WriteLn(' CON = screen like');
WriteLn(' NECP6 = NEC P6 Printer like.');
WriteLn(' NORTON = for NORTON-Guides');
WriteLn(' PRN = vanilla printer');
WriteLn;
WriteLn(' switches: (without spaces, 4. Parameter)');
WriteLn(' -A = append to destination file');
WriteLn(' -C = no keyword conversion');
WriteLn(' -P = no form-feed (FF) after last page');
END;
BEGIN
Assign( OutPut, ''); (* allow redirection of help text *)
Append( OutPut); (* append, the saver way ... *)
IF ParamCount < 1 THEN (* PPP = 0 args, give help *)
BEGIN
Help;
Halt(0); (* assume no error *)
END;
Angaben; (* get parameters and initialize *)
(*$IFDEF sort *) SortKeyWords; (*$ENDIF*)
(*$IFDEF debug *) ShowKeyWords; (*$ENDIF*)
InitPrinting; (* setup parameters and devices *)
ProcessText; (* process the INPUT file *)
IF colCnt <> 1 THEN BEGIN (* print head not at pos 1? *)
ListCh( #10); (* finish line *)
END;
IF Pos('-P', UpStr(
ParamStr(4)))=0 THEN
BEGIN (* final FF? *)
CondFF; (* only, if not already at *)
END; (* end of page *)
AbortProgram( ''); (* Shut down. *)
END. (* No message = No Error *)